perm filename GOBBLE.SAI[AL,HE]21 blob
sn#518987 filedate 1980-06-24 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00021 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 IFCR ¬DECLARATION(EXTENDED_COMPILATION) THENC
C00004 00003 ! CHANNEL STUFF: readfile
C00005 00004 ! Definitions
C00006 00005 ! rwdo, rwmake, dirmake, codemake, dtypmake, inpinit
C00014 00006 ! nextline, inscan, skipblanks, scan_token
C00018 00007 ! read and fread
C00020 00008 ! get_dtype, dtype, verify_dtype, verify_1, verify_2, verify_3, dtype_check
C00032 00009 ! new_var, new_exprn, new_lbl, asglbl
C00035 00010 ! asgbki, identlookup, ensym, vblmake, vtry
C00040 00011 ! evalexpr
C00048 00012 ! grovel (lllop, gllop, stmake, stgrovel, lgrovel, constelim)
C00052 00013 ! grovel: REGROVEL: DIR, EOP, DTYP
C00055 00014 ! grovel: DTYP: ARRAY, PROCEDURE
C00061 00015 ! grovel: main body: PROG,BLOCK,COBLOCK,FORR,WHIL,IFF,PAUSE,ABORT,COMMNT
C00065 00016 ! grovel: main body: CASE, RETURN
C00069 00017 ! grovel: main body: NOTE
C00071 00018 ! grovel: main body: AFFIX, UNFIX
C00073 00019 ! grovel: main body: V3ECT, TRANS, ASSIGNMENT, EVDO, PRNT, CMABLE
C00077 00020 ! grovel: main body: MOVE$, OPERATE, CENTER, STOP
C00093 00021 ! grovel: main body: motion clauses
C00110 ENDMK
C⊗;
IFCR ¬DECLARATION(EXTENDED_COMPILATION) THENC
ENTRY;
BEGIN "GOBBLE"
IFCR ¬DECLARATION(CREFFING) THENC DEFINE CREFFING="FALSE"; ENDC
IFCR ¬ CREFFING THENC
REQUIRE "ALREQ.HDR[AL,HE]" SOURCE_FILE;
ENDC
REDEFINE $$PRGID "[]" = ["GOBBLE"];
ENDC
RCLASS RESWD(STRING NAME; INTEGER TYPE, CODE; RPTR(RESWD) NEXT);
RCLASS IDENT(STRING ID; RPTR(IDENT) NEXT);
INTERNAL RCLASS DEFID(STRING NAME; RANY VAL; RPTR(DEFID) NEXT);
RPTR(RESWD) ARRAY BUCKET[1:26];
INTERNAL RPTR(DEFID) SYSIDS;
RPTR(DEFID) IDS;
RPTR(IDENT) IDENTS;
DEFINE DSKIN_OP = 1;
! CHANNEL STUFF: readfile;
DEFINE MAXFILES="15"; ! This is all an old relic, but why bother changing it;
STRING ARRAY FID[0:MAXFILES];
INTEGER ARRAY EOF[0:MAXFILES];
INTEGER ARRAY BRCHAR[0:MAXFILES];
INTEGER PROCEDURE READFILE(STRING FILEID;INTEGER DMODE(0));
BEGIN
INTEGER CH;
CH←GETCHAN;
FID[CH]←FILEID;
OPEN(CH,"DSK",DMODE,3,0,512,BRCHAR[CH],EOF[CH]);
LOOKUP(CH,FILEID,EOF[CH]);
IF EOF[CH] THEN
BEGIN
USERERR(1,1,"LOOKUP FAILED FOR |"&FILEID&"|");
RELEASE(CH);
CH←-1;
END;
RETURN(CH);
END;
! Definitions;
DEFINE MAXINPLEV=3;
INTEGER ARRAY SCNCHN[1:MAXINPLEV];
STRING ARRAY SCNSTK[0:MAXINPLEV];
INTEGER INPLEV;
RANY SYM;
INTEGER LINBRK,BLNKBRK,IDBRK,STRBRK;
DEFINE UNKN_CODE = 0; ! Unknown code;
DEFINE IDENT_CODE = 1; ! identifier;
DEFINE RW_CODE = 2; ! Reserved word;
DEFINE VAL_CODE = 3; ! Scalar value;
DEFINE STR_CODE = 4; ! String constant;
DEFINE DIR_CODE = 5; ! Directive (DSKIN);
DEFINE EOP_CODE = 6; ! Expression operation (SADD ...);
DEFINE DTYP_CODE = 7; ! Declaration (SVAR ...);
DEFINE PREDEC_CODE = 8; ! Predeclared variable/constant (BARM, XHAT...);
! rwdo, rwmake, dirmake, codemake, dtypmake, inpinit;
PROCEDURE RWDO(STRING ID;INTEGER TYPE,I);
BEGIN
INTEGER B;
RPTR(RESWD) V;
V ← NEW_RECORD(RESWD);
RESWD:NAME[V] ← ID;
RESWD:TYPE[V] ← TYPE;
RESWD:CODE[V] ← I;
B ← ID - '100; ! Use first character as index for proper bucket;
RESWD:NEXT[V] ← BUCKET[B];
BUCKET[B] ← V
END;
PROCEDURE RWMAKE(STRING ID;INTEGER I);
RWDO(ID,RW_CODE,I);
PROCEDURE DIRMAKE(STRING ID;INTEGER I);
RWDO(ID,DIR_CODE,I);
PROCEDURE CODEMAKE(STRING ID;INTEGER I);
RWDO(ID,EOP_CODE,I);
PROCEDURE DTYPMAKE(STRING ID;INTEGER I);
RWDO(ID,DTYP_CODE,I);
PROCEDURE INPINIT;
BEGIN
SETBREAK(LINBRK←GETBREAK,LF,CR,"INS"); ! line break;
SETBREAK(BLNKBRK←GETBREAK," "&'14&TAB&CR&LF,NULL,"XRN");
SETBREAK(IDBRK←GETBREAK,"ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$",NULL,"KXRN");
SETBREAK(STRBRK←GETBREAK,""""&LF,CR,"INS");
INPLEV←0;
DIRMAKE("DSKIN",DSKIN_OP);
RWMAKE("NULL",0);
RWMAKE("AFFIX",AFFIXTYPE);
RWMAKE("COMMENT",COMMNTTYPE);
RWMAKE("ON",CMONTYPE);
RWMAKE("EV",EVDOTYPE);
RWMAKE("CMABLE",CMABLETYPE);
RWMAKE("UNFIX",UNFIXTYPE);
RWMAKE("PR",PROGTYPE);
RWMAKE("BL",BLOCKTYPE);
RWMAKE("CO",COBLOCKTYPE);
RWMAKE("FO",FORRTYPE);
RWMAKE("WH",WHILTYPE);
RWMAKE("UNTL",UNTLTYPE);
RWMAKE("CASE",KASETYPE);
RWMAKE("IF",IFFTYPE);
RWMAKE("PAUSE",PAUSETYPE);
RWMAKE("PROMPT",PROMPTTYPE);
RWMAKE("ABORT",ABORTTYPE);
RWMAKE("RET",RETRNTYPE);
RWMAKE("AS",ASSIGNMENTTYPE);
RWMAKE("MO",MOVE$TYPE);
RWMAKE("TO",TO$TYPE);
RWMAKE("OPERATE",OPERATETYPE);
RWMAKE("CENTER",CENTERTYPE);
RWMAKE("ERROR",ERRORTYPE);
RWMAKE("RETRY",RETRYTYPE);
RWMAKE("STOP",STOPTYPE);
RWMAKE("DURATION",DURATIONTYPE);
RWMAKE("FORCE",FORCETYPE);
RWMAKE("STIFFNESS",STIFFTYPE);
RWMAKE("GATHER",GATHERTYPE);
RWMAKE("FORCE_FRAME",F_FRAMETYPE);
RWMAKE("SETBASE",SETBASETYPE); ! This and WRIST are temp hacks for JKS;
RWMAKE("WRIST",WRISTTYPE); ! so he can debug the force wrist;
RWMAKE("PRINT",PRNTTYPE);
RWMAKE("VIA",VIATYPE);
RWMAKE("VELOCITY",VELOCITYTYPE);
RWMAKE("ARRIVAL",APPROACHTYPE);
RWMAKE("DEPARTURE",DEPARTURETYPE);
RWMAKE("OPENING",OPENINGTYPE);
RWMAKE("WOBBLE",WOBBLETYPE);
RWMAKE("SPEED_FACTOR",S_FACTYPE);
RWMAKE("NNULL",NNULLTYPE);
RWMAKE("RTMOVE",RTMOVETYPE);
RWMAKE("SW_TIME",SW_TIMETYPE); ! for vise;
RWMAKE("CW",CWTYPE); ! for driver;
RWMAKE("NOTE",NOTETYPE);
RWMAKE("DEBUG",DEBUGTYPE); ! for debugging GROVEL;
CODEMAKE("NOOP",NO_OP);
CODEMAKE("CALL",CALL_OP);
CODEMAKE("AREF",AREF_OP);
CODEMAKE("SSBRTN",SSBRTN_OP);
CODEMAKE("SCALRD",SCALRD_OP);
CODEMAKE("SABS",SABS_OP);
CODEMAKE("SADD",SADD_OP);
CODEMAKE("SSUB",SSUB_OP);
CODEMAKE("SMUL",SMUL_OP);
CODEMAKE("SNEG",SNEG_OP);
CODEMAKE("SDIV",SDIV_OP);
CODEMAKE("STOS",SEXP_OP);
CODEMAKE("MAX",MAX_OP);
CODEMAKE("MIN",MIN_OP);
CODEMAKE("INT",INT_OP);
CODEMAKE("DIV",DIV_OP);
CODEMAKE("MOD",MOD_OP);
CODEMAKE("QUERY",QUERY_OP);
CODEMAKE("SLT",SLT_OP);
CODEMAKE("SEQ",SEQ_OP);
CODEMAKE("SLE",SLE_OP);
CODEMAKE("SGE",SGE_OP);
CODEMAKE("SNE",SNE_OP);
CODEMAKE("SGT",SGT_OP);
CODEMAKE("AND",AND_OP);
CODEMAKE("OR",OR_OP);
CODEMAKE("NOT",NOT_OP);
CODEMAKE("XOR",XOR_OP);
CODEMAKE("EQV",EQV_OP);
CODEMAKE("VMAGN",VMAGN_OP);
CODEMAKE("VDOT",VDOT_OP);
CODEMAKE("VMAKE",VMAKE_OP);
CODEMAKE("SVMUL",SVMUL_OP);
CODEMAKE("VSDIV",VSDIV_OP);
CODEMAKE("VADD",VADD_OP);
CODEMAKE("VSUB",VSUB_OP);
CODEMAKE("VCROSS",VCROSS_OP);
CODEMAKE("RVMUL",RVMUL_OP);
CODEMAKE("TVMUL",TVMUL_OP);
CODEMAKE("AXIS",AXIS_OP);
CODEMAKE("RMAGN",RMAGN_OP);
CODEMAKE("UVECT",UVECT_OP);
CODEMAKE("POS",POS_OP);
CODEMAKE("ORIENT",ORIENT_OP);
CODEMAKE("RRMUL",RRMUL_OP);
CODEMAKE("AXW_ROTN",AXW_ROTN_OP);
CODEMAKE("TMAKE",TMAKE_OP);
CODEMAKE("CONSTR",CONSTR_OP);
CODEMAKE("FTOF",FTOF_OP);
CODEMAKE("TVADD",TVADD_OP);
CODEMAKE("TVSUB",TVSUB_OP);
CODEMAKE("TTMUL",TTMUL_OP);
CODEMAKE("TINVRT",TINVRT_OP);
CODEMAKE("FMAKE",FMAKE_OP);
DTYPMAKE("REF",REF_DTYPE);
DTYPMAKE("VAL",VAL_DTYPE);
DTYPMAKE("SVAR",SVAL_DTYPE);
DTYPMAKE("VVAR",V3ECT_DTYPE);
DTYPMAKE("TVAR",TRANS_DTYPE);
DTYPMAKE("RVAR",ROTN_DTYPE);
DTYPMAKE("FVAR",FRAME_DTYPE);
DTYPMAKE("EVAR",EVENT_DTYPE);
DTYPMAKE("ARAY",ARAY_DTYPE);
DTYPMAKE("PROC",PROC_DTYPE);
DTYPMAKE("LAB",STMLAB_DTYPE);
DTYPMAKE("OMNLAB",OMNLAB_DTYPE);
DTYPMAKE("STMLAB",STMLAB_DTYPE);
END;
REQUIRE INPINIT INITIALIZATION [2];
! nextline, inscan, skipblanks, scan_token;
PROCEDURE NEXTLINE;
BEGIN
WHILE INPLEV>0 DO
BEGIN
IF ¬EOF[SCNCHN[INPLEV]] THEN
BEGIN
SCNSTK[INPLEV]←SCNSTK[INPLEV] & INPUT(SCNCHN[INPLEV],LINBRK);
RETURN;
END
ELSE
BEGIN
RELEASE(SCNCHN[INPLEV]);
INPLEV←INPLEV-1;
END;
END;
OUTSTR("*");
SCNSTK[0]←SCNSTK[0]&INCHWL&LF;
END;
STRING PROCEDURE INSCAN(INTEGER BRKTBL;REFERENCE INTEGER BC);
BEGIN
WHILE ¬LENGTH(SCNSTK[INPLEV]) DO NEXTLINE;
RETURN(SCAN(SCNSTK[INPLEV],BRKTBL,BC));
END;
INTEGER PROCEDURE SKIPBLANKS;
BEGIN
! returns the first non-"blank" character;
INTEGER C;
STRING S;
DO S←INSCAN(BLNKBRK,C) UNTIL C≠0;
RETURN(C);
END;
INTEGER PROCEDURE SCAN_TOKEN;
BEGIN
RANY R;
STRING SCNID;
INTEGER C,IX;
C ← SKIPBLANKS;
IF C = "$" THEN ! A reserved word;
BEGIN
SCNID ← INSCAN(IDBRK,C);
C ← LOP(SCNID); ! Ignore the $;
C ← SCNID - '100; ! Which bucket to check;
R ← BUCKET[C];
WHILE R ≠ RNULL ∧ ¬EQU(SCNID,RESWD:NAME[R]) DO R ← RESWD:NEXT[R];
IF R = RNULL THEN USERERR(1,1,"GOBBLE: UNKNOWN RESERVED WORD!");
SYM ← R;
RETURN(-1)
END;
IF "A" ≤(C LAND '137)≤ "Z" ∨ C="_" THEN ! an identifier;
BEGIN
INTEGER TYP;
SCNID←INSCAN(IDBRK,C);
R ← SYSIDS;
WHILE R ≠ RNULL ∧ ¬EQU(SCNID,DEFID:NAME[R]) DO R ← DEFID:NEXT[R];
IF R ≠ RNULL THEN
BEGIN
SYM ← DEFID:VAL[R]; ! Found it, return value;
RETURN(-1)
END;
R ← IDENTS;
WHILE R ≠ RNULL ∧ ¬EQU(SCNID,IDENT:ID[R]) DO R ← IDENT:NEXT[R];
IF R = RNULL THEN
BEGIN ! New - have to declare it now;
R ← NEW_RECORD(IDENT);
IDENT:ID[R] ← SCNID;
IDENT:NEXT[R] ← IDENTS;
IDENTS ← R
END;
SYM ← R;
RETURN(-1)
END;
IX ← IF C="-" ∨ C="+" THEN 2 ELSE 1;
IF SCNSTK[INPLEV][IX FOR 1]="." THEN IX ← IX+1;
IF "0"≤SCNSTK[INPLEV][IX FOR 1]≤"9" THEN
BEGIN
SYM ← NEW_RECORD(SVAL);
SVAL:VAL[SYM] ← REALSCAN(SCNSTK[INPLEV],C);
RETURN(-1)
END;
IF C="""" THEN
BEGIN
SCNID ← NULL;
WHILE TRUE DO
BEGIN
C ← LOP(SCNSTK[INPLEV]);
SCNID ← SCNID & INSCAN(STRBRK,C);
IF C="""" THEN
IF SCNSTK[INPLEV]="""" THEN SCNID←SCNID&LOP(SCNSTK[INPLEV])
ELSE DONE
ELSE IF C=LF ∨ C=0 THEN SCNID ← SCNID & CRLF
END;
IF SCNID = NULL THEN SCNID ← CRLF;
SYM ← NEW_RECORD(STCONST);
STCONST:VAL[SYM] ← SCNID;
RETURN(-1)
END;
C ← LOP(SCNSTK[INPLEV]);
RETURN(C)
END;
! read and fread;
INTERNAL RANY RECURSIVE PROCEDURE READ(INTEGER T(0));
BEGIN
RCELL LD;
RCELL C;
RANY V;
IF T=0 THEN T←SCAN_TOKEN;
IF T < 0 THEN RETURN(SYM);
IF T="(" THEN
BEGIN
LD ← C ← RNULL;
WHILE (T←SCAN_TOKEN) ≠ ")" DO
BEGIN
V ← CONS(READ(T),RNULL);
IF LD = RNULL THEN LD ← V ELSE CELL:CDR[C] ← V;
C ← V
END;
RETURN(LD)
END;
V ← NEW_RECORD(CHAR_REC);
CHAR_REC:CHAR[V] ← T;
RETURN(V)
END;
INTERNAL RANY PROCEDURE FREAD(STRING FILE_NAME);
BEGIN ! hack for linking with the parser and/or snail in rpg mode;
SCNSTK[0] ← "($DSKIN """&FILE_NAME&""") ";
RETURN(READ)
END;
! get_dtype, dtype, verify_dtype, verify_1, verify_2, verify_3, dtype_check;
FORWARD RPTR(VARIABLE) PROCEDURE VTRY
(RANY V;INTEGER DTYP (INVALID_DTYPE));
! On the next page;
INTEGER PROCEDURE GET_DTYPE(RANY X; INTEGER DTYP (INVALID_DTYPE));
BEGIN
! If X is a variable, VTRY is called on it with DTYP.
This helps in properly declaring undeclared variables
which are first used in expressions;
INTEGER I;
I ← RECTYPE(X);
RETURN ( IF I = LOC(EXPRN) THEN EXPRN:DATATYPE[X]
ELSE IF I = LOC(LBLVAR) THEN LBLVAR:DATATYPE[X]
ELSE IF I = LOC(VARIABLE) THEN VARIABLE:DATATYPE[VTRY(X,DTYP)]
ELSE IF I = LOC(ARRAYDEF) THEN ARRAYDEF:DATATYPE[X]
ELSE IF I = LOC(SVAL) THEN SVAL_DTYPE
ELSE IF I = LOC(V3ECT) THEN V3ECT_DTYPE
ELSE IF I = LOC(ROTN) THEN ROTN_DTYPE
ELSE IF I = LOC(TRANS) THEN TRANS_DTYPE
ELSE IF I = LOC(FRAME) THEN FRAME_DTYPE
ELSE INVALID_DTYPE)
END;
INTEGER SIMPLE PROCEDURE DTYPE(INTEGER DT);
START_CODE
MOVE 0,DT; ! this is cretinous, but ...;
MOVEI 1,0;
CAIN 0,SVAL_DTYPE;
MOVEI 1,SVAL;
CAIN 0,V3ECT_DTYPE;
MOVEI 1,V3ECT;
CAIN 0,ROTN_DTYPE;
MOVEI 1,ROTN;
CAIN 0,TRANS_DTYPE;
MOVEI 1,TRANS;
CAIN 0,FRAME_DTYPE;
MOVEI 1,FRAME;
END;
PROCEDURE VERIFY_DTYPE(RPTR(EXPRN,VARIABLE,VALU$) X;INTEGER T);
BEGIN
INTEGER TT;
TT ← GET_DTYPE(X,T);
IF TT≠T THEN
BEGIN
IF ¬(TT = FRAME_DTYPE ∧ T = TRANS_DTYPE) THEN
BEGIN
ALPRIN(X);
USERERR(1,1,"PARSER: wrong expression data type");
END
END
END;
PROCEDURE VERIFY_1(RCELL C;INTEGER T);
IF C=NULL THEN USERERR(1,1,"NOT ENOUGH ARGS")
ELSE VERIFY_DTYPE(CELL:CAR[C],T);
PROCEDURE VERIFY_2(RCELL C;INTEGER T1,T2);
IF CL_LEN(C) < 2 THEN USERERR(1,1,"NOT ENOUGH ARGS")
ELSE
BEGIN
VERIFY_DTYPE(CELL:CAR[C],T1);
VERIFY_DTYPE(CELL:CAR[CELL:CDR[C]],T2)
END;
PROCEDURE VERIFY_3(RCELL C;INTEGER T1,T2,T3);
IF C=NULL THEN USERERR(1,1,"NOT ENOUGH ARGS")
ELSE
BEGIN
VERIFY_DTYPE(CELL:CAR[C],T1);
VERIFY_2(CELL:CDR[C],T2,T3)
END;
PROCEDURE DTYPE_CHECK(RPTR(EXPRN) E);
BEGIN
INTEGER OP,NARGS;
RCELL EARGS,C,T;
RANY P;
OP ← EXPRN:OP[E];
EARGS ← EXPRN:ARGS[E];
EXPRN:DATATYPE[E] ←
IF OP = AREF_OP THEN ARRAYDEF:DATATYPE[P←LLOP(EARGS)]
ELSE IF OP = CALL_OP THEN PROCDEF:DATATYPE[P←LLOP(EARGS)]
ELSE IF MIN_SVAL_OP ≤ OP ≤ MAX_SVAL_OP THEN SVAL_DTYPE
ELSE IF MIN_V3ECT_OP ≤ OP ≤ MAX_V3ECT_OP THEN V3ECT_DTYPE
ELSE IF MIN_ROTN_OP ≤ OP ≤ MAX_ROTN_OP THEN ROTN_DTYPE
ELSE IF MIN_TRANS_OP ≤ OP ≤ MAX_TRANS_OP THEN TRANS_DTYPE
ELSE IF MIN_FRAME_OP ≤ OP ≤ MAX_FRAME_OP THEN FRAME_DTYPE
ELSE INVALID_DTYPE;
CASE OP OF BEGIN
[SCALRD_OP] [QUERY_OP] ; ! don't have any args;
[SABS_OP] VERIFY_1(EARGS,SVAL_DTYPE);
[SADD_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SSUB_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SNEG_OP] VERIFY_1(EARGS,SVAL_DTYPE);
[SMUL_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SDIV_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SEXP_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[MAX_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[MIN_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[INT_OP] VERIFY_1(EARGS,SVAL_DTYPE);
[DIV_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[MOD_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SLT_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SGT_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SEQ_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SLE_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SGE_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SNE_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[AND_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[OR_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[NOT_OP] VERIFY_1(EARGS,SVAL_DTYPE);
[XOR_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[EQV_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[VMAGN_OP] VERIFY_1(EARGS,V3ECT_DTYPE);
[VDOT_OP] VERIFY_2(EARGS,V3ECT_DTYPE,V3ECT_DTYPE);
[SVMUL_OP] VERIFY_2(EARGS,SVAL_DTYPE,V3ECT_DTYPE);
[VSDIV_OP] VERIFY_2(EARGS,V3ECT_DTYPE,SVAL_DTYPE);
[VMAKE_OP] VERIFY_3(EARGS,SVAL_DTYPE,SVAL_DTYPE,SVAL_DTYPE);
[VADD_OP] VERIFY_2(EARGS,V3ECT_DTYPE,V3ECT_DTYPE);
[VSUB_OP] VERIFY_2(EARGS,V3ECT_DTYPE,V3ECT_DTYPE);
[VCROSS_OP] VERIFY_2(EARGS,V3ECT_DTYPE,V3ECT_DTYPE);
[TVMUL_OP] VERIFY_2(EARGS,TRANS_DTYPE,V3ECT_DTYPE);
[TVADD_OP] VERIFY_2(EARGS,TRANS_DTYPE,V3ECT_DTYPE);
[TVSUB_OP] VERIFY_2(EARGS,TRANS_DTYPE,V3ECT_DTYPE);
[RVMUL_OP] VERIFY_2(EARGS,ROTN_DTYPE,V3ECT_DTYPE);
[RMAGN_OP] VERIFY_1(EARGS,ROTN_DTYPE);
[AXIS_OP] VERIFY_1(EARGS,ROTN_DTYPE);
[POS_OP] VERIFY_1(EARGS,TRANS_DTYPE);
[ORIENT_OP] VERIFY_1(EARGS,TRANS_DTYPE);
[RRMUL_OP] VERIFY_2(EARGS,ROTN_DTYPE,ROTN_DTYPE);
[UVECT_OP] VERIFY_1(EARGS,V3ECT_DTYPE);
[AXW_ROTN_OP] VERIFY_2(EARGS,V3ECT_DTYPE,SVAL_DTYPE);
[FTOF_OP] VERIFY_2(EARGS,FRAME_DTYPE,FRAME_DTYPE);
[TMAKE_OP] VERIFY_2(EARGS,ROTN_DTYPE,V3ECT_DTYPE);
[CONSTR_OP] VERIFY_3(EARGS,V3ECT_DTYPE,V3ECT_DTYPE,V3ECT_DTYPE);
[TTMUL_OP] VERIFY_2(EARGS,TRANS_DTYPE,TRANS_DTYPE);
[TINVRT_OP] VERIFY_1(EARGS,TRANS_DTYPE);
[FMAKE_OP] VERIFY_2(EARGS,ROTN_DTYPE,V3ECT_DTYPE);
[SSBRTN_OP] CASE (OP ← SVAL:VAL[CELL:CAR[EARGS]]) OF
BEGIN
[SQRT_OP] [SIN_OP] [COS_OP] [TAN_OP]
[ASIN_OP] [ACOS_OP]
[LOG_OP] [EXP_OP]
[TIME_OP] VERIFY_1(CELL:CDR[EARGS],SVAL_DTYPE);
[ATAN2_OP] VERIFY_2(CELL:CDR[EARGS],SVAL_DTYPE,SVAL_DTYPE)
END;
[CALL_OP] BEGIN "procedure call"
NARGS ← 0;
T ← PROCDEF:ARGS[P];
WHILE EARGS ≠ RNULL DO
BEGIN "count args"
NARGS ← NARGS + 1;
VERIFY_DTYPE((C←LLOP(EARGS)),VARIABLE:DATATYPE[LLOP(T)])
END;
IF NARGS < PROCDEF:NUMARGS[P] THEN
BEGIN "not enough args"
USERERR(1,1,"PARSER: NOT ENOUGH ARGMENTS FOR PROCEDURE");
IF C = RNULL THEN C ← CELL:CDR[EXPRN:ARGS[E]];
WHILE NARGS < PROCDEF:NUMARGS[P] DO
BEGIN
NARGS ← NARGS + 1;
CASE VARIABLE:DATATYPE[LLOP(T)] OF
BEGIN
[SVAL_DTYPE] C ← CELL:CDR[C] ← CONS(FALSEV,RNULL);
[V3ECT_DTYPE] C ← CELL:CDR[C] ← CONS(NILVECT,RNULL);
[ROTN_DTYPE] C ← CELL:CDR[C] ← CONS(NILROTN,RNULL);
[TRANS_DTYPE] C ← CELL:CDR[C] ← CONS(NILTRANS,RNULL);
[FRAME_DTYPE] C ← CELL:CDR[C] ← CONS(NILDEPROACH,RNULL);
ELSE C ← CELL:CDR[C] ← CONS(FALSEV,RNULL)
END
END
END "not enough args"
END "procedure call";
[AREF_OP] BEGIN "array reference"
NARGS ← 0;
WHILE EARGS ≠ RNULL DO
BEGIN "count args"
NARGS ← NARGS + 1;
VERIFY_DTYPE((C←LLOP(EARGS)),SVAL_DTYPE)
END;
IF NARGS < ARRAYDEF:NUMDIMS[P] THEN
BEGIN "not enough subscripts"
USERERR(1,1,"PARSER: NOT ENOUGH SUBSCRIPTS");
IF C = RNULL THEN C ← CELL:CDR[EXPRN:ARGS[E]];
WHILE NARGS < ARRAYDEF:NUMDIMS[P] DO
BEGIN
NARGS ← NARGS + 1;
C ← CELL:CDR[C]
← CONS(ARRAYDEF:BOUNDS[P][NARGS,0],RNULL)
END
END "not enough subscripts"
END "array reference";
[LAST_OP] END;
END;
! new_var, new_exprn, new_lbl, asglbl;
RPTR(VARIABLE) PROCEDURE NEW_VAR(STRING NAME; INTEGER DT; RBLK BID);
BEGIN
RVAR VAR;
VAR ← NEW_RECORD(VARIABLE);
VARIABLE:NAME[VAR] ← NAME;
VARIABLE:DATATYPE[VAR] ← DT;
VARIABLE:BLK[VAR] ← BID;
IF BID ≠ RNULL THEN
IF DT = EVENT_DTYPE THEN CONSON(VAR,BLOCK:EVTS[BID])
ELSE CONSON(VAR,BLOCK:VARS[BID]);
RETURN(VAR);
END;
INTERNAL RPTR(EXPRN) PROCEDURE NEW_EXPRN(INTEGER DT,OP;RCELL ARGS);
BEGIN
RPTR(EXPRN) E;
E←NEW_RECORD(EXPRN);
EXPRN:DATATYPE[E]←DT;
EXPRN:OP[E]←OP;
EXPRN:ARGS[E]←ARGS;
RETURN(E);
END;
RPTR(LBLVAR) PROCEDURE NEW_LBL(STRING NAME; INTEGER DT; RBLK BID);
BEGIN
RPTR(LBLVAR) L;
L ← NEW_RECORD(LBLVAR);
LBLVAR:DATATYPE[L] ← DT;
LBLVAR:BLK[L] ← BID;
LBLVAR:NAME[L] ← NAME;
RETURN(L);
END;
RANY PROCEDURE ASGLBL(RPTR(LBLVAR) L;RPTR(ANY_CLASS) SEM);
BEGIN
IF RECTYPE(SEM) = LOC(STMNT) THEN ! have the stmnt point to the label;
BEGIN
STMNT:STLAB[SEM] ← L;
IF RECTYPE(STMNT:SEMANTICS[SEM]) = LOC(CMON) THEN
SEM ← STMNT:SEMANTICS[SEM];
END;
IF RECTYPE(SEM) = LOC(CMON) THEN LBLVAR:DATATYPE[L] ← OMNLAB_DTYPE;
LBLVAR:SEMANTICS[L] ← SEM;
RETURN(SEM)
END;
! asgbki, identlookup, ensym, vblmake, vtry;
RPTR(BLOCK) GVLBLK; ! Current block being gobbled;
RPTR(CMON) CCMON; ! Current cmon being gobbled (if any);
INTEGER TEMP; INITIALIZE(TEMP←0);
INTEGER BLKNO; INITIALIZE(BLKNO←0);
PROCEDURE ASGBKI(RPTR(BLOCK) B);
BEGIN
BLKNO ← BLKNO + 1;
BLOCK:BLID[B] ← "$B" & CVS(BLKNO)
END;
RANY PROCEDURE IDENTLOOKUP(RPTR(IDENT) V);
BEGIN
RPTR(DEFID) D;
IF RECTYPE(V) ≠ LOC(IDENT) THEN
BEGIN
USERERR(1,1,"DRYROT IN IDENTLOOKUP");
RETURN(RNULL)
END;
D ← IDS;
WHILE D ≠ RNULL ∧ ¬EQU(IDENT:ID[V],DEFID:NAME[D]) DO D ← DEFID:NEXT[D];
IF D ≠ RNULL THEN RETURN (DEFID:VAL[D]) ! Success - found it;
ELSE RETURN (V) ! Failure - not defined;
END;
PROCEDURE ENSYM(RPTR(IDENT) ID; RANY V);
BEGIN
RANY D;
IF RECTYPE(ID) ≠ LOC(IDENT) THEN
BEGIN
PRINT(CRLF&"****", IDENT:ID[ID], CRLF);
USERERR(1,1,"NEED AN ID HERE");
RETURN
END;
D ← IDENTLOOKUP(ID);
IF RECTYPE(D) ≠ LOC(IDENT) ∧ VARIABLE:BLK[D] = GVLBLK THEN
USERERR(1,1,"WARNING DUP ID: " & IDENT:ID[ID])
ELSE
BEGIN ! Add a new defid to the list;
D ← NEW_RECORD(DEFID);
DEFID:NAME[D] ← IDENT:ID[ID];
DEFID:VAL[D] ← V;
DEFID:NEXT[D] ← IDS;
IDS ← D
END
END;
RPTR(VARIABLE,LBLVAR) PROCEDURE VBLMAKE(RPTR(IDENT) V; INTEGER DTYP);
BEGIN
RPTR(VARIABLE,LBLVAR) VV;
IF DTYP = STMLAB_DTYPE ∨ DTYP = OMNLAB_DTYPE THEN
VV ← NEW_LBL(IDENT:ID[V],DTYP,GVLBLK)
ELSE
VV ← NEW_VAR(IDENT:ID[V],DTYP,GVLBLK);
ENSYM(V,VV);
RETURN(VV)
END;
RPTR(VARIABLE,LBLVAR) PROCEDURE VTRY(RANY V; INTEGER DTYP (INVALID_DTYPE));
BEGIN "vtry"
! Returns V. If it was a declared variable, it
checks its type to make sure it is DTYP (unless DTYP was not
specified). If it was not declared, VTRY declares it with DTYP.
Complains if V is not a declared variable or an IDENT.;
RVAR VAR;
INTEGER RT,VDT;
RT ← RECTYPE(V);
IF RT = LOC(IDENT) THEN
BEGIN
V ← IDENTLOOKUP(V);
RT ← RECTYPE(V)
END;
IF RT = LOC(IDENT) THEN
BEGIN ! Must be declared;
USERERR(1,1,"VTRY: Will define " & IDENT:ID[V]);
VAR ← VBLMAKE(V,DTYP)
END
ELSE IF RT = LOC(ARRAYDEF) THEN RETURN(V)
ELSE IF RT = LOC(PROCDEF) THEN RETURN(V)
ELSE IF RT = LOC(VARIABLE) THEN VAR ← V
ELSE IF RT = LOC(LBLVAR) THEN RETURN(V)
ELSE BEGIN
USERERR(1,1,"VTRY: Bad argument");
RETURN(V)
END;
VDT ← VARIABLE:DATATYPE[VAR];
IF (DTYP ≠ INVALID_DTYPE) ∧ (VDT ≠ DTYP) THEN
BEGIN ! May want to put right type in;
IF VDT = INVALID_DTYPE THEN VARIABLE:DATATYPE[VAR] ← DTYP
ELSE IF VDT = FRAME_DTYPE ∧ DTYP=TRANS_DTYPE THEN BEGIN ! OK; END
ELSE USERERR(1,1,"VTRY: " & VARIABLE:NAME[V] & " has wrong type")
END;
RETURN(VAR)
END "vtry";
! evalexpr;
RPTR(VALU$) RECPROC EVALEXPR(RPTR(EXPRN,VARIABLE,VALU$) E);
BEGIN
! evaluates the value of expression-like thing E
& returns a value (e.g., vector, sval, trans) ;
RPTR(CELL) C;
RPTR(VALU$) V1,V2,V3;
INTEGER ETYP;
RPTR(VALU$) PROCEDURE TFCVT(RPTR(VALU$) V);
IF RECTYPE(V)=LOC(FRAME) THEN RETURN(FRAME:VAL[V])
ELSE RETURN(V);
IF E=NULL_RECORD THEN RETURN(E);
ETYP ← RECTYPE(E);
IF ETYP=LOC(SVAL) ∨ ETYP=LOC(FRAME) ∨ ETYP=LOC(TRANS) ∨
ETYP=LOC(V3ECT) ∨ ETYP=LOC(ROTN) THEN
RETURN(E)
ELSE IF ETYP=LOC(FORCE) THEN
RETURN(NEW_SVAL(0)) ! No idea what the actual value will be;
ELSE IF ETYP≠LOC(EXPRN) THEN
BEGIN
USERERR(1,1,"EVALEXPR: BAD ARGUMENT");
RETURN(NULL_RECORD);
END;
C←EXPRN:ARGS[E];
IF EXPRN:OP[E]=AREF_OP ∨ EXPRN:OP[E]=CALL_OP ∨ EXPRN:OP[E]=QUERY_OP
THEN C←RNULL;
IF C≠NULL_RECORD THEN V1←TFCVT(EVALEXPR(LLOP(C)));
IF C≠NULL_RECORD THEN V2←TFCVT(EVALEXPR(LLOP(C)));
IF C≠NULL_RECORD THEN V3←TFCVT(EVALEXPR(LLOP(C)));
CASE EXPRN:OP[E] OF
BEGIN
[NO_OP] RETURN(V1);
[SCALRD_OP]
[QUERY_OP] RETURN(FALSEV);
[SABS_OP] RETURN(NEW_SVAL(ABS SVAL:VAL[V1]));
[SNEG_OP] RETURN(NEW_SVAL(-SVAL:VAL[V1]));
[SADD_OP] RETURN(NEW_SVAL(SVAL:VAL[V1]+SVAL:VAL[V2]));
[SSUB_OP] RETURN(NEW_SVAL(SVAL:VAL[V1]-SVAL:VAL[V2]));
[SMUL_OP] RETURN(NEW_SVAL(SVAL:VAL[V1]*SVAL:VAL[V2]));
[SDIV_OP] RETURN(NEW_SVAL(SVAL:VAL[V1]/SVAL:VAL[V2]));
[SEXP_OP] RETURN(NEW_SVAL(SVAL:VAL[V1]↑SVAL:VAL[V2]));
[MAX_OP] RETURN(NEW_SVAL(SVAL:VAL[V1] MAX SVAL:VAL[V2]));
[MIN_OP] RETURN(NEW_SVAL(SVAL:VAL[V1] MIN SVAL:VAL[V2]));
[INT_OP] RETURN(NEW_SVAL(SVAL:VAL[V1] DIV 1));
[DIV_OP] RETURN(NEW_SVAL(SVAL:VAL[V1] DIV SVAL:VAL[V2]));
[MOD_OP] RETURN(NEW_SVAL(SVAL:VAL[V1] MOD SVAL:VAL[V2]));
[SLT_OP] RETURN(NEW_SVAL(SVAL:VAL[V1]<SVAL:VAL[V2]));
[SEQ_OP] RETURN(NEW_SVAL(SVAL:VAL[V1]=SVAL:VAL[V2]));
[SLE_OP] RETURN(NEW_SVAL(SVAL:VAL[V1]≤SVAL:VAL[V2]));
[SGE_OP] RETURN(NEW_SVAL(SVAL:VAL[V1]≥SVAL:VAL[V2]));
[SNE_OP] RETURN(NEW_SVAL(SVAL:VAL[V1]≠SVAL:VAL[V2]));
[SGT_OP] RETURN(NEW_SVAL(SVAL:VAL[V1]>SVAL:VAL[V2]));
[AND_OP] RETURN(NEW_SVAL(SVAL:VAL[V1]∧SVAL:VAL[V2]));
[OR_OP] RETURN(NEW_SVAL(SVAL:VAL[V1]∨SVAL:VAL[V2]));
[NOT_OP] RETURN(NEW_SVAL(¬SVAL:VAL[V1]));
[XOR_OP] RETURN(NEW_SVAL(SVAL:VAL[V1]⊗SVAL:VAL[V2]));
[EQV_OP] RETURN(NEW_SVAL(SVAL:VAL[V1]≡SVAL:VAL[V2]));
[VMAGN_OP] RETURN(NEW_SVAL(SQRT(V3DOT(V1,V1))));
[VDOT_OP] RETURN(NEW_SVAL(V3DOT(V1,V2)));
[VCROSS_OP] RETURN(V3CROSS(V1,V2));
[RMAGN_OP] RETURN(RMAGN(V1));
[AXIS_OP] RETURN(AXIS(V1));
[SVMUL_OP] RETURN(SVMUL(SVAL:VAL[V1],V2));
[VSDIV_OP] RETURN(SVMUL(1.0/SVAL:VAL[V2],V1));
[VMAKE_OP] RETURN(NEW_V3ECT(SVAL:VAL[V1],SVAL:VAL[V2],SVAL:VAL[V3]));
[VADD_OP] RETURN(V3ADD(V1,V2));
[VSUB_OP] RETURN(V3SUB(V1,V2));
[RVMUL_OP] RETURN(RVMUL(V1,V2));
[UVECT_OP] RETURN(UVECT(V1));
[POS_OP] RETURN(POS(V1));
[ORIENT_OP] RETURN(ORIENT(V1));
[AXW_ROTN_OP] RETURN(AXW_ROTN(V1,SVAL:VAL[V2]));
[RRMUL_OP] RETURN(RRMUL(V1,V2));
[TMAKE_OP] RETURN(NEW_TRANS(CHKREC(V1,LOC(ROTN)),CHKREC(V2,LOC(V3ECT)) ));
[CONSTR_OP] RETURN(CONSTR(V1,V2,V3));
[TVADD_OP] RETURN(NEW_TRANS(TRANS:R[V1],V3ADD(TRANS:P[V1],V2)));
[TVSUB_OP] RETURN(NEW_TRANS(TRANS:R[V1],V3SUB(TRANS:P[V1],V2)));
[TVMUL_OP] RETURN(TVMUL(V1,V2));
[FTOF_OP] RETURN(TTMUL(TINVRT(CHKREC(V1,LOC(TRANS))),CHKREC(V2,LOC(TRANS))) );
[TTMUL_OP] RETURN(TTMUL(V1,V2));
[TINVRT_OP] RETURN(TINVRT(V1));
[FMAKE_OP] RETURN(NEW_FRAME(
NEW_TRANS(CHKREC(V1,LOC(ROTN)),CHKREC(V2,LOC(V3ECT)) ) ));
[TFMAKE_OP] RETURN(NEW_FRAME(V1));
[SSBRTN_OP] CASE (ETYP←SVAL:VAL[V1]) OF
BEGIN
[SQRT_OP] RETURN(NEW_SVAL(SQRT(SVAL:VAL[V2])));
[SIN_OP] RETURN(NEW_SVAL(SIND(SVAL:VAL[V2])));
[COS_OP] RETURN(NEW_SVAL(COSD(SVAL:VAL[V2])));
[TAN_OP] RETURN(NEW_SVAL(SIND(SVAL:VAL[V2])/COSD(SVAL:VAL[V2])));
[ASIN_OP] RETURN(NEW_SVAL(ASIN(SVAL:VAL[V2]) * DEG));
[ACOS_OP] RETURN(NEW_SVAL(ACOS(SVAL:VAL[V2]) * DEG));
[ATAN2_OP] RETURN(NEW_SVAL(ATAN2(SVAL:VAL[V2],SVAL:VAL[V3])*DEG));
[LOG_OP] RETURN(NEW_SVAL(LOG(SVAL:VAL[V2])));
[EXP_OP] RETURN(NEW_SVAL(EXP(SVAL:VAL[V2])));
[TIME_OP] RETURN(NEW_SVAL(SVAL:VAL[V2]+1.0))
END;
[LAST_OP] END;
USERERR(1,1,"EVALEXPR: INVALID OP");
RETURN(NULL_RECORD);
END;
! grovel (lllop, gllop, stmake, stgrovel, lgrovel, constelim);
RANY CURRENT_CF; INITIALIZE(CURRENT_CF←BARM);
INTERNAL RANY RECPROC GROVEL(RANY SE);
BEGIN
RCELL C;
RANY KIND,V;
INTEGER IX;
OWN INTEGER REFFLG, VALFLG; ! Used for reference & value decs;
LABEL REGROVEL;
RANY PROCEDURE LLLOP;
RETURN(LLOP(C));
RANY PROCEDURE GLLOP;
IF C ≠ RNULL THEN RETURN(GROVEL(LLLOP)) ELSE RETURN(RNULL);
RPTR(STMNT) PROCEDURE STMAKE(RSSS SEM(NULL_RECORD));
BEGIN
RPTR(STMNT) S;
S←NEW_RECORD(STMNT);
STMNT:SEMANTICS[S]←SEM;
RETURN(S);
END;
RSTMNT PROCEDURE STGROVEL;
IF C ≠ RNULL THEN
BEGIN
RANY S;
S ← GLLOP;
IF RECTYPE(S)=LOC(EXPRN) ∧ EXPRN:OP[S]=CALL_OP THEN S ← STMAKE(S);
RETURN(CHKREC(S,LOC(STMNT)))
END
ELSE RETURN(STMAKE(RNULL));
RCELL RECPROC LGROVEL(RCELL C);
BEGIN ! Grovels down a list;
RCELL C1,C2,C3;
C1 ← C3 ← RNULL;
WHILE C ≠ RNULL DO
BEGIN
C2 ← GROVEL(LLOP(C));
IF C2 ≠ RNULL THEN
BEGIN
C2 ← CONS(C2,RNULL);
IF C1 = RNULL THEN C1 ← C3 ← C2
ELSE CELL:CDR[C1] ← C2;
C1 ← C2
END
END;
RETURN(C3)
END;
RPTR (VALU$,EXPRN) PROCEDURE CONSTELIM (RPTR(EXPRN) EX);
BEGIN "constelim" ! Takes the expression EX and
replaces it with a simpler one if possible. At the moment, only
checks one level deep, since it is called repeatedly at each level.
It should be simple to make it recursive;
INTEGER TYP, FLAG;
RANY PTR;
IF RECTYPE(EX) ≠ LOC(EXPRN) THEN
BEGIN
PRINT(CRLF&"****"); ALPRIN(EX);
USERERR(1,1,"CONSTELIM: Not an expression");
RETURN(EX);
END;
! Make sure the operands are all constants;
PTR ← EXPRN:ARGS[EX];
FLAG ← FALSE;
WHILE PTR ≠ RNULL DO
BEGIN "cloop"
TYP ← RECTYPE(CELL:CAR[PTR]);
IF FLAG ← (TYP=LOC(SVAL) ∨ TYP=LOC(V3ECT) ∨ TYP=LOC(ROTN) ∨ TYP=LOC(TRANS)
∨ TYP=LOC(FRAME)) THEN PTR ← CELL:CDR[PTR]
ELSE DONE "cloop"
END "cloop";
IF ¬FLAG THEN RETURN(EX) ! Can't do anything;
ELSE RETURN(EVALEXPR(EX))
END;
! grovel: REGROVEL: DIR, EOP, DTYP;
REGROVEL:
IF RECTYPE(SE) ≠ LOC(CELL) THEN
IF RECTYPE(SE) = LOC(IDENT) THEN RETURN(VTRY(SE)) ELSE RETURN(SE);
KIND ← CELL:CAR[SE];
C ← CELL:CDR[SE];
IX ← RECTYPE(KIND);
IF IX = LOC(IDENT) THEN
BEGIN
KIND ← IDENTLOOKUP(KIND);
IX ← RECTYPE(KIND);
END;
IF IX = LOC(LBLVAR) THEN
BEGIN
V ← GROVEL(C);
IX ← RECTYPE(V);
IF LBLVAR:SEMANTICS[KIND] ≠ RNULL THEN
BEGIN
PRINT(CRLF&"****"); ALPRIN(KIND);
USERERR(1,1,"DUPLICATE USE OF LABEL")
END
ELSE ASGLBL(KIND,V);
RETURN(V)
END
ELSE IF IX ≠ LOC(RESWD) THEN RETURN(LGROVEL(SE));
IX ← RESWD:TYPE[KIND];
CASE IX OF
BEGIN
[DIR_CODE] BEGIN ! DSKIN_OP is only directive;
V ← GLLOP;
IF RECTYPE(V) = LOC(STCONST) THEN
BEGIN
INTEGER CH;
CH ← READFILE(STCONST:VAL[V]);
IF CH < 0 THEN RETURN(RNULL);
INPLEV ← INPLEV+1;
SCNCHN[INPLEV] ← CH;
SCNSTK[INPLEV] ← INPUT(SCNCHN[INPLEV],LINBRK);
IF EQU(SCNSTK[INPLEV][1 FOR 9],"COMMENT ⊗") THEN
BEGIN ! Skip over E directory page;
DO SCNSTK[INPLEV] ← INPUT(SCNCHN[INPLEV],LINBRK)
UNTIL EQU(SCNSTK[INPLEV][1 FOR 3],"C⊗;")
∨ EOF[SCNCHN[INPLEV]];
IF EOF[SCNCHN[INPLEV]] THEN
USERERR(1,1,"DIRECTORY END NOT DETECTED");
SCNSTK[INPLEV] ← NULL
END;
SE ← READ;
GO TO REGROVEL
END
END;
[EOP_CODE] BEGIN ! Expression;
V ← NEW_RECORD(EXPRN);
EXPRN:OP[V] ← RESWD:CODE[KIND];
EXPRN:ARGS[V] ← LGROVEL(C);
DTYPE_CHECK(V);
IF ¬(EXPRN:OP[V] = SSBRTN_OP ∧
SVAL:VAL[CELL:CAR[EXPRN:ARGS[V]]] = TIME_OP) THEN
V ← CONSTELIM(V);
RETURN(V)
END;
! grovel: DTYP: ARRAY, PROCEDURE;
[DTYP_CODE] BEGIN "VBL"
IF RESWD:CODE[KIND] = REF_DTYPE THEN
BEGIN "refdec"
REFFLG ← TRUE;
GROVEL(C);
REFFLG ← FALSE
END
ELSE IF RESWD:CODE[KIND] = VAL_DTYPE THEN
BEGIN "valdec"
VALFLG ← TRUE;
GROVEL(C);
VALFLG ← FALSE
END
ELSE IF RESWD:CODE[KIND] = ARAY_DTYPE THEN
BEGIN "array dec"
INTEGER DT,NDIMS,I,J;
RPTR(ARRAYDEF) ARAY;
RCELL BNDS;
DT ← RESWD:CODE[LLLOP];
WHILE C ≠ RNULL DO
BEGIN
ARAY ← NEW_RECORD(ARRAYDEF);
ARRAYDEF:DATATYPE[ARAY] ← DT;
ARRAYDEF:BLK[ARAY] ← GVLBLK;
CONSON(ARAY,BLOCK:ARAYS[GVLBLK]);
V ← LLLOP; ! fetch array name;
ARRAYDEF:NAME[ARAY] ← IDENT:ID[V];
ENSYM(V,ARAY);
BNDS ← CELL:CAR[C];
NDIMS ← 0;
WHILE BNDS ≠ RNULL DO
BEGIN
NDIMS ← NDIMS + 1;
BNDS ← CELL:CDR[CELL:CDR[BNDS]]
END;
ARRAYDEF:NUMDIMS[ARAY] ← NDIMS;
IF NDIMS THEN
BEGIN ! this is so procedure arguments can be arrays;
NewArray(REXPR,ARRAYDEF:BOUNDS[ARAY],[1:NDIMS,0:3]);
END;
BNDS ← LLLOP;
FOR I ← 1 TIL NDIMS DO
FOR J ← 0 TIL 1 DO
BEGIN
ARRAYDEF:BOUNDS[ARAY][I,J] ← GROVEL(LLOP(BNDS));
IF RECTYPE(ARRAYDEF:BOUNDS[ARAY][I,J]) = LOC(EXPRN) THEN
ARRAYDEF:BOUNDS[ARAY][I,J+2] ←
NEW_VAR(NULL,SVAL_DTYPE,BLOCK:PARENT[GVLBLK])
END
END
END "array dec"
ELSE IF RESWD:CODE[KIND] = PROC_DTYPE THEN
BEGIN "procedure dec"
INTEGER NARGS;
RPTR(BLOCK) SAVEBLK,T;
RPTR(DEFID) BLKIDS;
RANY P,N;
RCELL ARGLIST,L;
V ← NEW_RECORD(PROCDEF);
PROCDEF:DATATYPE[V] ← (IF RECTYPE(CELL:CAR[C]) =
LOC(RESWD) THEN RESWD:CODE[LLLOP] ELSE 0);
CONSON(V,BLOCK:PROCS[GVLBLK]);
P ← LLLOP; ! get procedure's name;
PROCDEF:NAME[V] ← IDENT:ID[P];
ENSYM(P,V);
PROCDEF:BLK[V] ← GVLBLK;
BLKIDS ← IDS;
T ← NEW_RECORD(BLOCK);
PROCDEF:BODY[V] ← STMAKE(T);
ASGBKI(T);
BLOCK:PARENT[T] ← SAVEBLK ← GVLBLK;
GVLBLK ← T;
L ← RNULL;
ARGLIST ← CELL:CAR[C]; ! save pointer to arg list;
LGROVEL(LLLOP); ! parse the arg list defining variables;
WHILE ARGLIST ≠ RNULL DO
BEGIN
P ← LLOP(ARGLIST);
WHILE P ≠ RNULL DO
IF RECTYPE((N←LLOP(P))) = LOC(IDENT) THEN
BEGIN
NARGS ← NARGS + 1;
N ← CONS(IDENTLOOKUP(N),RNULL);
IF L = RNULL THEN PROCDEF:ARGS[V] ← N
ELSE CELL:CDR[L] ← N;
L ← N
END
END;
PROCDEF:NUMARGS[V] ← NARGS;
BLOCK:CODE[T] ← LGROVEL(C); ! parse procedure body;
IDS ← BLKIDS; ! Pop variables for this block;
GVLBLK ← SAVEBLK
END "procedure dec"
ELSE WHILE C ≠ RNULL DO
BEGIN
V ← LLLOP;
IF RECTYPE(V) ≠ LOC(IDENT) THEN
BEGIN
PRINT(CRLF&"****"); RECPRN(V); PRINT(CRLF);
USERERR(1,1,"FUNNY THING FOR VARIABLE");
CONTINUE
END;
V ← VBLMAKE(V,RESWD:CODE[KIND]);
IX ← IF REFFLG THEN REFARG ELSE IF VALFLG THEN VALARG ELSE 0;
VARIABLE:ATTRIBUTES[V] ← VARIABLE:ATTRIBUTES[V] LOR IX
END;
RETURN(RNULL)
END;
! grovel: main body: PROG,BLOCK,COBLOCK,FORR,WHIL,IFF,PAUSE,ABORT,COMMNT;
[RW_CODE] BEGIN "RWCODE"
CASE RESWD:CODE[KIND] OF
BEGIN
[PROGTYPE] BEGIN
V←NEW_RECORD(PROG);
PROG:CODE[V]←STGROVEL;
RETURN(STMAKE(V))
END;
[BLOCKTYPE] BEGIN
RBLK SAVEBLK;
RPTR(DEFID) BLKIDS;
V ← NEW_RECORD(BLOCK);
BLKIDS ← IDS;
ASGBKI(V);
SAVEBLK ← GVLBLK;
BLOCK:PARENT[V] ← SAVEBLK;
GVLBLK ← V;
BLOCK:CODE[V] ← LGROVEL(C);
IDS ← BLKIDS; ! Pop variables for this block;
GVLBLK ← SAVEBLK;
RETURN(STMAKE(V))
END;
[COBLOCKTYPE] BEGIN
V ← NEW_RECORD(COBLOCK);
COBLOCK:CODE[V] ← LGROVEL(C);
RETURN(STMAKE(V))
END;
[FORRTYPE] BEGIN
V ← NEW_RECORD(FORR);
FORR:CONVAR[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,SVAL_DTYPE) ELSE GLLOP);
FORR:INITIAL[V] ← GLLOP;
FORR:STEP[V] ← GLLOP;
FORR:FINAL[V] ← GLLOP;
FORR:BODY[V] ← STGROVEL;
RETURN(STMAKE(V))
END;
[WHILTYPE] BEGIN
V ← NEW_RECORD(WHIL);
WHIL:COND[V] ← GLLOP;
WHIL:BODY[V] ← STGROVEL;
RETURN(STMAKE(V))
END;
[UNTLTYPE] BEGIN
V ← NEW_RECORD(UNTL);
UNTL:BODY[V] ← STGROVEL;
UNTL:COND[V] ← GLLOP;
RETURN(STMAKE(V))
END;
[IFFTYPE] BEGIN
V ← NEW_RECORD(IFF);
IFF:COND[V] ← GLLOP;
IFF:THN[V] ← STGROVEL;
IFF:ELS[V] ← STGROVEL;
RETURN(STMAKE(V))
END;
[PAUSETYPE] BEGIN
V ← NEW_RECORD(PAUSE);
PAUSE:VAL[V] ← GLLOP;
RETURN(STMAKE(V))
END;
[PROMPTTYPE] BEGIN
V ← NEW_RECORD(PROMPT);
PROMPT:VAL[V] ← LGROVEL(C); ! Gets a list of print items;
RETURN(STMAKE(V))
END;
[ABORTTYPE] BEGIN
V ← NEW_RECORD(ABORT);
ABORT:VAL[V] ← LGROVEL(C); ! Gets a list of print items;
RETURN(STMAKE(V))
END;
[COMMNTTYPE] BEGIN ! Coded by RF;
V ← NEW_RECORD(COMMNT);
! COMMNT:HESAYS[V] ← LGROVEL(C);
! You don't really want to keep that junk;
RETURN(STMAKE(V))
END;
! grovel: main body: CASE, RETURN;
[KASETYPE] BEGIN
RANY F;
RCELL T,B;
INTEGER S,I,N,J;
V ← NEW_RECORD(KASE);
S ← I ← N ← 0;
KASE:INDEX[V] ← GLLOP;
IF RECTYPE(CELL:CAR[C]) = LOC(CELL) THEN
BEGIN "regular case statement"
T ← C;
WHILE T ≠ RNULL DO ! count the statements;
BEGIN LLOP(T); N ← N +1 END;
KASE:RANGE[V] ← N;
NewArray(INTEGER,KASE:LABS[V],[0:N,0:1]);
ARRCLR(KASE:LABS[V],N);
FOR I ← 0 TIL N-1 DO
IF (F←LLLOP) = RNULL THEN KASE:LABS[V][I,0] ← N ELSE
BEGIN
KASE:LABS[V][I,0] ← S;
S ← S + 1;
F ← GROVEL(F);
IF RECTYPE(F)=LOC(EXPRN) ∧ EXPRN:OP[F]=CALL_OP THEN
F←STMAKE(F);
F ← CONS(F,RNULL);
IF T = RNULL THEN KASE:STMNTS[V] ← F
ELSE CELL:CDR[T] ← F;
T ← F
END
END "regular case statement"
ELSE
BEGIN "numbered case statement"
T ← C;
WHILE T ≠ RNULL DO ! establish the range of the index;
IF RECTYPE(F←LLOP(T)) = LOC(SVAL) THEN
N ← N MAX (I←SVAL:VAL[F]);
KASE:RANGE[V] ← N ← N + 1;
NewArray(INTEGER,KASE:LABS[V],[0:N,0:1]);
ARRCLR(KASE:LABS[V],N);
B ← C; I ← 0;
WHILE C ≠ RNULL DO
IF (F←LLLOP) = RNULL THEN BEGIN "whoops"
WHILE B≠C DO IF RECTYPE(F←LLOP(B))=LOC(SVAL) THEN
KASE:LABS[V][SVAL:VAL[F],0] ← N END "whoops"
ELSE IF RECTYPE(F) = LOC(SVAL) THEN
IF SVAL:VAL[F] ≥ 0 THEN
KASE:LABS[V][SVAL:VAL[F],0] ← S
ELSE
BEGIN
FOR J ← 0 TIL N DO
IF KASE:LABS[V][J,0] = N THEN
KASE:LABS[V][J,0] ← S;
KASE:RANGE[V] ← - KASE:RANGE[V]
END
ELSE
BEGIN
B ← C; S ← S + 1;
F ← GROVEL(F);
IF RECTYPE(F)=LOC(EXPRN) ∧ EXPRN:OP[F]=CALL_OP THEN
F←STMAKE(F);
F ← CONS(F,RNULL);
IF T = RNULL THEN KASE:STMNTS[V] ← F
ELSE CELL:CDR[T] ← F;
T ← F
END
END "numbered case statement";
KASE:NSTMNTS[V] ← S;
IF KASE:RANGE[V] ≥ 0 THEN KASE:LABS[V][N,0] ← S;
RETURN(STMAKE(V))
END;
[RETRNTYPE] BEGIN
V ← NEW_RECORD(RETRN);
RETRN:VAL[V] ← GLLOP;
RETURN(STMAKE(V))
END;
! grovel: main body: NOTE;
[NOTETYPE] BEGIN
V ← NEW_RECORD(NOTE);
NOTE:HESAYS[V] ← GLLOP; ! Better be a string constant;
RETURN(V)
END;
[DEBUGTYPE] BEGIN
PRINT(STCONST:VAL[GLLOP],CRLF); ! Better be a string constant;
RETURN(RNULL)
END;
! grovel: main body: AFFIX, UNFIX;
[AFFIXTYPE] BEGIN
RPTR(VARIABLE) VAR;
V←NEW_RECORD(AFFIX);
AFFIX:FRAME1[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,FRAME_DTYPE) ELSE GLLOP);
AFFIX:FRAME2[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,FRAME_DTYPE) ELSE GLLOP);
AFFIX:BYVAR[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,TRANS_DTYPE) ELSE GLLOP);
IF AFFIX:BYVAR[V] = RNULL THEN
BEGIN
AFFIX:BYVAR[V] ← VAR ← NEW_RECORD(VARIABLE);
VARIABLE:NAME[VAR] ← NULL;
VARIABLE:DATATYPE[VAR] ← TRANS_DTYPE;
VARIABLE:BLK[VAR] ← GVLBLK
END;
AFFIX:ATEXP[V] ← GLLOP;
AFFIX:RIGID[V] ← ! Rigid (=TRUE) is default;
C = RNULL ∨ ¬EQU("NONRIGIDLY",IDENT:ID[LLOP(C)]);
RETURN(STMAKE(V))
END;
[UNFIXTYPE] BEGIN
V←NEW_RECORD(UNFIX);
UNFIX:FRAME1[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,FRAME_DTYPE) ELSE GLLOP);
UNFIX:FRAME2[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,FRAME_DTYPE) ELSE GLLOP);
RETURN(STMAKE(V))
END;
! grovel: main body: V3ECT, TRANS, ASSIGNMENT, EVDO, PRNT, CMABLE;
[V3ECTTYPE] BEGIN
V ← NEW_RECORD(V3ECT);
V3ECT:X[V] ← SVAL:VAL[LLLOP];
V3ECT:Y[V] ← SVAL:VAL[LLLOP];
V3ECT:Z[V] ← SVAL:VAL[LLLOP];
RETURN(V)
END;
[TRANSTYPE] BEGIN
V ← NEW_RECORD(TRANS);
TRANS:R[V] ← GLLOP;
TRANS:P[V] ← GLLOP;
RETURN(V)
END;
[PRNTTYPE] BEGIN "prnt"
V ← NEW_RECORD(PRNT);
PRNT:VAL[V] ← LGROVEL(C); ! Gets a list of print items;
RETURN(STMAKE(V))
END "prnt";
[ASSIGNMENTTYPE] BEGIN "assign"
V ← NEW_RECORD(ASSIGNMENT);
ASSIGNMENT:VAR[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN LLLOP ELSE GLLOP);
ASSIGNMENT:VAL[V] ← GLLOP;
IF RECTYPE(ASSIGNMENT:VAR[V]) = LOC(IDENT) THEN
ASSIGNMENT:VAR[V] ←
VTRY(ASSIGNMENT:VAR[V],GET_DTYPE(ASSIGNMENT:VAL[V]));
RETURN(STMAKE(V))
END "assign";
[EVDOTYPE] BEGIN
! e.g.: (EV EVAR1 +) will signal the event;
V ← NEW_RECORD(EVDO);
EVDO:VAR[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,EVENT_DTYPE) ELSE GLLOP);
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
IF IX = "+" THEN EVDO:OP[V] ← 0
ELSE IF IX = "-" THEN EVDO:OP[V] ← 1
ELSE USERERR(1,1,"What kind of EV is " & IX & "?");
RETURN(STMAKE(V))
END;
[CMABLETYPE] BEGIN
! e.g.: (CMABLE + cmon) will enable the cmon;
V ← NEW_RECORD(CMABLE);
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
IF IX = "+" THEN CMABLE:FLAG[V] ← 0
ELSE IF IX = "-" THEN CMABLE:FLAG[V] ← 1
ELSE USERERR(1,1,"What kind of CMABLE is " & IX & "?");
! Get the cmon's label;
IF C ≠ RNULL THEN ! refers to labelled cmon;
CMABLE:WHAT[V] ← VTRY(LLLOP,OMNLAB_DTYPE)
ELSE ! refers to unlabelled cmon;
IF IX="-" THEN USERERR(1,1,"Cmon can't disable itself.")
ELSE
IF CCMON ≠ RNULL THEN CMABLE:WHAT[V] ← CCMON
ELSE USERERR(1,1,"Must specify name of cmon.");
RETURN(STMAKE(V))
END;
! grovel: main body: MOVE$, OPERATE, CENTER, STOP;
[MOVE$TYPE] BEGIN "move$"
RANY OLD_CF,X;
RCELL P;
REXPR DEP;
RPTR(APPROACH) ARR;
RPTR(FORCE) F;
RPTR(F_FRAME) F_F;
RPTR(SETBASE) ZWRIST;
BOOLEAN ARRIVE,DEPART;
INTEGER DT,RT,USE_FORCE,CM_FORCE,USE_COMPLY,I;
V ← NEW_RECORD(MOVE$);
OLD_CF ← CURRENT_CF;
CURRENT_CF ← MOVE$:CF[V] ← GLLOP;
DT ← GET_DTYPE(MOVE$:CF[V]);
MOVE$:DEST[V] ← GLLOP;
! Can expect VIA, DURATION, CMON, DEPROACHES;
MOVE$:CLAUSES[V] ← LGROVEL(C);
P ← MOVE$:CLAUSES[V];
WHILE P ≠ RNULL DO
BEGIN
! First turn CMON & S_FAC statements into regular clauses;
IF RECTYPE(CELL:CAR[P])=LOC(STMNT) THEN
CELL:CAR[P]←STMNT:SEMANTICS[CELL:CAR[P]];
X←LLOP(P);
IF (RT←RECTYPE(X))=LOC(CMON) THEN
BEGIN
IF RECTYPE(CMON:CONDITION[X]) = LOC(FORCE) THEN
CM_FORCE ← CM_FORCE + 1;
END
ELSE IF RT=LOC(TO$) THEN MOVE$:DEST[V] ← TO$:VAL[X]
ELSE IF RT=LOC(FORCE) THEN USE_FORCE ← USE_FORCE + 1
ELSE IF RT=LOC(STIFF) THEN USE_COMPLY ← 1
ELSE IF RT=LOC(F_FRAME) THEN F_F ← X
ELSE IF RT=LOC(SETBASE) THEN ZWRIST ← X
ELSE IF RT=LOC(APPROACH) THEN
BEGIN
ARRIVE ← TRUE;
DEP ← APPROACH:THRU[X];
IF (RT←RECTYPE(DEP))=LOC(VARIABLE) THEN
RT ← DTYPE(VARIABLE:DATATYPE[DEP])
ELSE IF RT=LOC(EXPRN) THEN RT←DTYPE(EXPRN:DATATYPE[DEP]);
IF DEP ≠ NILDEPROACH THEN
APPROACH:ACTPLACE[X] ← NEW_EXPRN(TRANS_DTYPE,
TTMUL_OP,LIST2(MOVE$:DEST[V],DEP));
END
ELSE IF RT=LOC(DEPARTURE) THEN
BEGIN
DEPART ← TRUE;
DEP ← DEPARTURE:THRU[X];
IF (RT←RECTYPE(DEP))=LOC(VARIABLE) THEN
RT ← DTYPE(VARIABLE:DATATYPE[DEP])
ELSE IF RT=LOC(EXPRN) THEN RT←DTYPE(EXPRN:DATATYPE[DEP]);
IF DEP ≠ NILDEPROACH THEN
DEPARTURE:ACTPLACE[X] ← NEW_EXPRN(TRANS_DTYPE,
TTMUL_OP,LIST2(MOVE$:CF[V],DEP));
END
END;
IF ¬ARRIVE ∧ DT=FRAME_DTYPE ∧
((RT←RECTYPE(MOVE$:DEST[V]))=LOC(VARIABLE) ∨
(RT=LOC(EXPRN) ∧ EXPRN:OP[MOVE$:DEST[V]]=AREF_OP)) THEN
BEGIN ! add approach;
ARR ← NEW_RECORD(APPROACH);
CONSON(ARR,MOVE$:CLAUSES[V]);
APPROACH:ACTPLACE[ARR] ← NEW_EXPRN(TRANS_DTYPE,TVADD_OP,
LIST2(MOVE$:DEST[V],STAN_DEPROACH));
END;
IF ¬ USE_FORCE ∧ CM_FORCE = 1 THEN
BEGIN "only sense"
P ← MOVE$:CLAUSES[V];
DO X ← LLOP(P) UNTIL RECTYPE(X)=LOC(CMON) ∧
RECTYPE(CMON:CONDITION[X])=LOC(FORCE);
F ← CMON:CONDITION[X];
IF FORCE:F_F[F] = RNULL ∧ F_F = RNULL ∧
(FORCE:DIRECT[F] = XHAT ∨ FORCE:DIRECT[F] = YHAT ∨
FORCE:DIRECT[F] =ZHAT ∨
(RECTYPE(X←FORCE:DIRECT[F]) = LOC(V3ECT) ∧
( V3CMP(X,NEGXHAT)=0 ∨ V3CMP(X,NEGYHAT)=0 ∨
V3CMP(X,NEGZHAT)=0 ) ) ) THEN
BEGIN ! Need to specify a force frame;
FORCE:F_F[F] ← F_F ← NEW_RECORD(F_FRAME);
F_FRAME:FRAME[F_F] ← STATION; ! Standard orientation;
F_FRAME:C_SYS[F_F] ← FTABLE; ! Table coordinates;
F_FRAME:CF[F_F] ← CURRENT_CF; ! Current control frame;
END;
IF FORCE:F_F[F] ≠ RNULL THEN F_F ← FORCE:F_F[F];
END "only sense"
ELSE IF USE_FORCE ∨ CM_FORCE THEN
BEGIN "multiple sense/apply"
I ← USE_FORCE + CM_FORCE;
P ← MOVE$:CLAUSES[V];
WHILE I DO
BEGIN "find the force clauses"
X ← LLOP(P);
IF (RT←RECTYPE(X))=LOC(CMON) ∧
RECTYPE(CMON:CONDITION[X])=LOC(FORCE)
THEN F ← CMON:CONDITION[X]
ELSE IF RT=LOC(FORCE) THEN F ← X ELSE CONTINUE;
I ← I - 1;
IF RECTYPE(FORCE:DIRECT[F]) = LOC(V3ECT) ∧
( V3CMP(FORCE:DIRECT[F],NEGXHAT)=0 ∨
V3CMP(FORCE:DIRECT[F],NEGYHAT)=0 ∨
V3CMP(FORCE:DIRECT[F],NEGZHAT)=0 ) THEN
BEGIN ! Reverse direction of axis & flip rel;
IF V3CMP(FORCE:DIRECT[F],NEGXHAT)=0 THEN
FORCE:DIRECT[F]←XHAT ELSE
IF V3CMP(FORCE:DIRECT[F],NEGYHAT)=0 THEN
FORCE:DIRECT[F]←YHAT
ELSE FORCE:DIRECT[F]←ZHAT;
FORCE:REL[F] ← FORCE:REL[F] XOR (SIGLT LOR SIGGE);
END;
IF FORCE:DIRECT[F]≠XHAT ∧ FORCE:DIRECT[F]≠YHAT ∧
FORCE:DIRECT[F]≠ZHAT THEN
IF USE_FORCE + CM_FORCE = 1 THEN
BEGIN "single apply"
IF F_F ≠ RNULL THEN
BEGIN ! Multiply defined force frames;
ALPRIN(V);
BUG("MOVE statement has multiply defined force frames");
END;
IF FORCE:F_F[F] = RNULL THEN
BEGIN ! Make up a force frame;
F_F ← FORCE:F_F[F] ← NEW_RECORD(F_FRAME);
F_FRAME:FRAME[F_F] ← STATION;
F_FRAME:C_SYS[F_F] ← FTABLE;
F_FRAME:CF[F_F] ← CURRENT_CF
END
ELSE IF TRANSCMP(NILTRANS,
FRAME:VAL[F_FRAME:FRAME[FORCE:F_F[F]]]) THEN
FORCE:DIRECT[F] ←
NEW_EXPRN(V3ECT_DTYPE,RVMUL_OP,
LIST2(NEW_EXPRN(ROTN_DTYPE,ORIENT_OP,
CONS(F_FRAME:FRAME[FORCE:F_F[F]],
RNULL)),
FORCE:DIRECT[F]));
DONE;
END "single apply"
ELSE BEGIN "axis error"
ALPRIN(V);
PRINT(crlf & "Force direction must be along" &
" an axis - Assuming ZHAT");
FORCE:DIRECT[F] ← ZHAT;
END "axis error";
IF F_F = RNULL THEN F_F ← FORCE:F_F[F] ! Make the first;
! force frame we see the default,
! unless the MOVE specified one;
ELSE IF FORCE:F_F[F] ≠ RNULL ∧
(F_FRAME:FRAME[F_F]≠F_FRAME:FRAME[FORCE:F_F[F]] ∨
F_FRAME:C_SYS[F_F]≠F_FRAME:C_SYS[FORCE:F_F[F]])
THEN
BEGIN ! Multiply defined force frames;
ALPRIN(V);
BUG("MOVE statement has multiply defined force frames");
END;
IF RT=LOC(CMON) THEN FORCE:F_F[F] ← RNULL;
! null out the field so cmon's will be coded right;
END "find the force clauses";
IF F_F = RNULL ∧ USE_FORCE+CM_FORCE ≥ 1 THEN
BEGIN ! no force frame specified;
! ALPRIN(V);
! PRINT(crlf &"No force frame specified in MOVE statement"
! & " - Assuming station");
F_F ← NEW_RECORD(F_FRAME);
F_FRAME:FRAME[F_F] ← STATION; ! Standard orientation;
F_FRAME:C_SYS[F_F] ← FTABLE; ! Table coordinates;
F_FRAME:CF[F_F] ← CURRENT_CF; ! Current control frame;
END;
IF F_F ≠ RNULL THEN CONSON(F_F,MOVE$:CLAUSES[V]);
! May already be somewhere in clause list, but...;
END "multiple sense/apply";
IF ZWRIST = RNULL ∧ CM_FORCE + USE_FORCE + USE_COMPLY ≥ 1 THEN
BEGIN ! Want to zero wrist;
ZWRIST ← NEW_RECORD(SETBASE);
SETBASE:VAL[ZWRIST] ← TRUE;
CONSON(ZWRIST,MOVE$:CLAUSES[V]);
END;
IF USE_FORCE ∧ ¬USE_COMPLY THEN
BEGIN ! Need to add a stiffness specification;
X ← NEW_RECORD(STIFF);
STIFF:K[X] ← NEW_V3ECT(40.0,40.0,40.0);
STIFF:G[X] ← NEW_V3ECT(100.0,100.0,100.0);
STIFF:F_F[X] ← NEW_RECORD(F_FRAME); ! Fill in default force_frame;
F_FRAME:FRAME[STIFF:F_F[X]] ← STATION; ! Standard orientation;
F_FRAME:C_SYS[STIFF:F_F[X]] ← FTABLE; ! Table coordinates;
F_FRAME:CF[STIFF:F_F[X]] ← CURRENT_CF; ! Which arm;
CONSON(X,MOVE$:CLAUSES[V]);
END;
CURRENT_CF ← OLD_CF;
RETURN(STMAKE(V))
END "move$";
[OPERATETYPE] BEGIN "operate" ! only for vise & driver;
RCELL P;
BOOLEAN CCW;
RANY OLD_CF;
V ← NEW_RECORD(OPERATE);
OLD_CF ← CURRENT_CF;
CURRENT_CF ← OPERATE:CF[V] ← GLLOP;
IF OPERATE:CF[V] ≠ VISE ∧ OPERATE:CF[V] ≠ DRIVER THEN
BEGIN ! not a valid device;
PRINT(CRLF & "WARNING: can't operate: ",
VARIABLE:NAME[OPERATE:CF[V]]);
END;
OPERATE:DEST[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(CHAR_REC)
THEN LLLOP ELSE GLLOP);
! Can expect DURATION, CMON, TORQUE, VELOCITY,
STOP_WAIT_TIME, ... ;
OPERATE:CLAUSES[V] ← LGROVEL(C);
P←MOVE$:CLAUSES[V];
WHILE P ≠ RNULL DO ! All this does is turn CMON & S_FAC;
BEGIN ! statements into regular clauses;
IF RECTYPE(CELL:CAR[P])=LOC(STMNT) THEN
CELL:CAR[P]←STMNT:SEMANTICS[CELL:CAR[P]];
IF RECTYPE(CELL:CAR[P])=LOC(CW) THEN
CCW ← CW:FLAG[CELL:CAR[P]];
P←CELL:CDR[P]
END;
IF OPERATE:CF[V] = DRIVER ∧ CCW THEN
BEGIN ! Need to negate ang_vel/torque;
P←OPERATE:CLAUSES[V];
WHILE P≠NULL_RECORD DO
BEGIN ! find clauses to negate;
RANY X;INTEGER RT;
X←LLOP(P);
IF (RT←RECTYPE(X))=LOCATION(FORCE) THEN
BEGIN ! negate torque;
FORCE:VAL[X]←IF RECTYPE(FORCE:VAL[X])=LOC(SVAL)
THEN NEW_SVAL(-SVAL:VAL[FORCE:VAL[X]])
ELSE NEW_EXPRN(SVAL_DTYPE,SNEG_OP,
CONS(FORCE:VAL[X],RNULL))
END
ELSE IF RT=LOCATION(VELOCITY) THEN
BEGIN ! negate velocity;
VELOCITY:VELOC[X] ←
IF RECTYPE(VELOCITY:VELOC[X])=LOC(SVAL)
THEN NEW_SVAL(-SVAL:VAL[VELOCITY:VELOC[X]])
ELSE NEW_EXPRN(SVAL_DTYPE,SNEG_OP,
CONS(VELOCITY:VELOC[X],RNULL))
END
END
END;
CURRENT_CF ← OLD_CF;
RETURN(STMAKE(V))
END "operate";
[CENTERTYPE] BEGIN "center"
RANY P;
V ← NEW_RECORD(CENTER);
CENTER:CF[V] ← GLLOP;
! Can expect CMON someday, ERROR handler now;
CENTER:CLAUSES[V] ← LGROVEL(C);
P←CENTER:CLAUSES[V];
WHILE P ≠ RNULL DO ! All this does is turn CMON & S_FAC;
BEGIN ! statements into regular clauses;
IF RECTYPE(CELL:CAR[P])=LOC(STMNT) THEN
CELL:CAR[P]←STMNT:SEMANTICS[CELL:CAR[P]];
P←CELL:CDR[P]
END;
RETURN(STMAKE(V))
END "center";
[RETRYTYPE] BEGIN "retry"
V ← NEW_RECORD(RETRY);
RETURN(STMAKE(V))
END "retry";
[STOPTYPE] BEGIN "stop"
V ← NEW_RECORD(STOP);
STOP:CF[V] ← GLLOP;
IF STOP:CF[V] = RNULL THEN STOP:CF[V] ← CURRENT_CF;
RETURN(STMAKE(V))
END "stop";
! grovel: main body: motion clauses;
[CMONTYPE] BEGIN "cmon"
RPTR(CMON) S;
S ← CCMON; ! save outermost cmon;
CCMON ← V ← NEW_RECORD(CMON);
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
IF IX = "+" THEN CMON:FLAGS[V] ← 0 ! Regular cmon;
ELSE IF IX = "-" THEN CMON:FLAGS[V] ← 1 ! Deferred cmon;
ELSE USERERR(1,1,"What kind of CMON is " & IX & "?");
CMON:CONDITION[V] ← GLLOP;
IF CMON:CONDITION[V] = ARRIVAL THEN ! Replace ARRIVAL by an event;
CMON:CONDITION[V] ←
NEW_VAR(".AE"&CVS(TEMP←TEMP+1),EVENT_DTYPE,GVLBLK);
CMON:CONCLUSION[V] ← STGROVEL;
CCMON ← S; ! restore old outermost cmon;
IF RECTYPE(CMON:CONDITION[V]) = LOC(ERROR) THEN
BEGIN ! treat error handler specially;
ERROR:BODY[CMON:CONDITION[V]] ← CMON:CONCLUSION[V];
RETURN(CMON:CONDITION[V]);
END;
IF RECTYPE(CMON:CONDITION[V]) = LOC(FORCE) THEN
BEGIN ! See if we should stop arm when cmon is triggered;
RANY XX;
RCELL CC;
XX ← STMNT:SEMANTICS[CMON:CONCLUSION[V]];
IF RECTYPE(XX) = LOC(STOP) ∧ STOP:CF[XX] = CURRENT_CF THEN
BEGIN
CMON:FLAGS[V] ← CMON:FLAGS[V] + FSTOP;
CMON:CONCLUSION[V] ← RNULL
END
ELSE IF RECTYPE(XX) = LOC(BLOCK) THEN
BEGIN ! Check if first statement is a STOP;
CC ← BLOCK:CODE[XX];
WHILE RECTYPE(CELL:CAR[CC]) ≠ LOC(STMNT) DO CC ← CELL:CDR[CC];
IF CC ≠ RNULL THEN XX ← STMNT:SEMANTICS[CELL:CAR[CC]];
IF RECTYPE(XX) = LOC(STOP) ∧ STOP:CF[XX] = CURRENT_CF THEN
BEGIN
CMON:FLAGS[V] ← CMON:FLAGS[V] + FSTOP;
IF CELL:CDR[CC] ≠ RNULL THEN
BEGIN ! Splice out this cell from list;
CELL:CAR[CC] ← CELL:CAR[CELL:CDR[CC]];
CELL:CDR[CC] ← CELL:CDR[CELL:CDR[CC]];
END
ELSE CELL:CAR[CC] ← RNULL;
END
END
END;
CONSON(V,BLOCK:CMONS[GVLBLK]);
RETURN(STMAKE(V))
END "cmon";
[ERRORTYPE] BEGIN "error"
V ← NEW_RECORD(ERROR);
ERROR:BITS[V] ← GLLOP;
IF RECTYPE(ERROR:BITS[V]) ≠ LOC(SVAL) THEN
USERERR(1,1,"Error condition bits must be a constant.");
RETURN(V)
END "error";
[VIATYPE] BEGIN "via"
RANY CLS; ! Clause;
V ← NEW_RECORD(VIA);
VIA:PLACE[V] ← GLLOP;
VERIFY_DTYPE(VIA:PLACE[V],TRANS_DTYPE); ! Check type is ok;
WHILE C ≠ RNULL DO
BEGIN
IF RECTYPE(CLS←GLLOP) = LOC(VELOCITY) THEN
VIA:VELOC[V] ← CLS
ELSE IF RECTYPE(CLS) = LOC(DURATION) THEN
VIA:TIME[V] ← CLS
ELSE IF RECTYPE(CLS) = LOC(STMNT) THEN
IF RECTYPE(STMNT:SEMANTICS[CLS]) = LOC(EVDO)
∧ EVDO:OP[STMNT:SEMANTICS[CLS]]=0
THEN ! Treat SIGNAL as special;
VIA:CODE[V] ← STMNT:SEMANTICS[CLS]
ELSE
BEGIN
RPTR(CMON) S;
VIA:CODE[V] ← S ← NEW_RECORD(CMON);
CMON:CONDITION[S] ←
NEW_VAR(".E"&CVS(TEMP←TEMP+1),EVENT_DTYPE,GVLBLK);
CMON:CONCLUSION[S] ← CLS;
CONSON(S,BLOCK:CMONS[GVLBLK]);
END
ELSE BEGIN ALPRIN(CLS);PRINT(CRLF);
USERERR(1,1,"Funny thing for VIA clause") END;
END;
RETURN(V)
END "via";
[APPROACHTYPE] BEGIN "approach"
REXPR DEP;
INTEGER DT,RT;
RANY CLS; ! Clause for code;
V ← NEW_RECORD(APPROACH);
APPROACH:THRU[V] ← GLLOP;
DEP ← APPROACH:THRU[V];
IF DEP ≠ NILDEPROACH THEN
BEGIN
IF (RT←RECTYPE(DEP))=LOC(VARIABLE) THEN
RT ← DTYPE(VARIABLE:DATATYPE[DEP])
ELSE IF RT=LOC(EXPRN) THEN RT←DTYPE(EXPRN:DATATYPE[DEP]);
IF RT = LOC(SVAL) THEN
APPROACH:THRU[V] ←
NEW_EXPRN(TRANS_DTYPE,TMAKE_OP,LIST2(NILROTN,
NEW_EXPRN(V3ECT_DTYPE,SVMUL_OP,LIST2(DEP,ZHAT))))
ELSE IF RT = LOC(V3ECT) THEN
APPROACH:THRU[V] ←
NEW_EXPRN(TRANS_DTYPE,TMAKE_OP,LIST2(NILROTN,DEP));
END;
CLS ← GLLOP;
IF CLS ≠ RNULL THEN ! Deal with associated code;
IF RECTYPE(STMNT:SEMANTICS[CLS]) = LOC(EVDO)
∧ EVDO:OP[STMNT:SEMANTICS[CLS]]=0
THEN ! Treat SIGNAL as special;
APPROACH:CODE[V] ← STMNT:SEMANTICS[CLS]
ELSE
BEGIN
RPTR(CMON) S;
APPROACH:CODE[V] ← S ← NEW_RECORD(CMON);
CMON:CONDITION[S] ←
NEW_VAR(".E"&CVS(TEMP←TEMP+1),EVENT_DTYPE,GVLBLK);
CMON:CONCLUSION[S] ← CLS;
CONSON(S,BLOCK:CMONS[GVLBLK]);
END;
RETURN(V)
END "approach";
[DEPARTURETYPE] BEGIN "departure"
REXPR DEP;
INTEGER DT,RT;
RANY CLS; ! Clause for code;
V ← NEW_RECORD(DEPARTURE);
DEPARTURE:THRU[V] ← GLLOP;
DEP ← DEPARTURE:THRU[V];
IF DEP ≠ NILDEPROACH THEN
BEGIN
IF (RT←RECTYPE(DEP))=LOC(VARIABLE) THEN
RT ← DTYPE(VARIABLE:DATATYPE[DEP])
ELSE IF RT=LOC(EXPRN) THEN RT←DTYPE(EXPRN:DATATYPE[DEP]);
IF RT = LOC(SVAL) THEN
DEPARTURE:THRU[V] ←
NEW_EXPRN(TRANS_DTYPE,TMAKE_OP,LIST2(NILROTN,
NEW_EXPRN(V3ECT_DTYPE,SVMUL_OP,LIST2(DEP,ZHAT))))
ELSE IF RT = LOC(V3ECT) THEN
DEPARTURE:THRU[V] ←
NEW_EXPRN(TRANS_DTYPE,TMAKE_OP,LIST2(NILROTN,DEP));
END;
CLS ← GLLOP;
IF CLS ≠ RNULL THEN ! Deal with associated code;
IF RECTYPE(STMNT:SEMANTICS[CLS]) = LOC(EVDO)
∧ EVDO:OP[STMNT:SEMANTICS[CLS]]=0
THEN ! Treat SIGNAL as special;
DEPARTURE:CODE[V] ← STMNT:SEMANTICS[CLS]
ELSE
BEGIN
RPTR(CMON) S;
DEPARTURE:CODE[V] ← S ← NEW_RECORD(CMON);
CMON:CONDITION[S] ←
NEW_VAR(".E"&CVS(TEMP←TEMP+1),EVENT_DTYPE,GVLBLK);
CMON:CONCLUSION[S] ← CLS;
CONSON(S,BLOCK:CMONS[GVLBLK]);
END;
RETURN(V)
END "departure";
[WOBBLETYPE] BEGIN "wobble"
V ← NEW_RECORD(WOBBLE);
WOBBLE:VAL[V] ← GLLOP;
RETURN(V)
END "wobble";
[OPENINGTYPE] BEGIN "opening"
V ← NEW_RECORD(OPENING);
OPENING:VAL[V] ← GLLOP;
RETURN(V)
END "opening";
[DURATIONTYPE] BEGIN "duration"
V ← NEW_RECORD(DURATION);
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
DURATION:TIME_RELN[V] ←
IF IX = ">" THEN '20 ! 1 lsh 4;
ELSE IF IX = "≥" THEN '20 ! 1 lsh 4;
ELSE IF IX = "<" THEN '40 ! 2 lsh 4;
ELSE IF IX = "≤" THEN '40 ! 2 lsh 4;
ELSE IF IX = "=" THEN '60 ! 3 lsh 4;
ELSE 0;
DURATION:TIME[V] ← GLLOP;
RETURN(V)
END "duration";
[VELOCITYTYPE] BEGIN "velocity"
V ← NEW_RECORD(VELOCITY);
VELOCITY:VELOC[V] ← GLLOP;
RETURN(V)
END "velocity";
[FORCETYPE] BEGIN "force"
V ← NEW_RECORD(FORCE);
FORCE:DIRECT[V] ← GLLOP;
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
FORCE:REL[V] ← IF IX = "<" THEN SIGLT ELSE SIGGE;
! treat "=" & "≥" the same;
IF RECTYPE(CELL:CAR[C]) = LOC(CHAR_REC) THEN
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
IF IX = "+" THEN FORCE:REL[V] ← FORCE:REL[V] LOR SIGMAG;
FORCE:VAL[V] ← GLLOP;
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
FORCE:TYPE[V] ← IF IX = "-" THEN FALSE ELSE TRUE;
! force along axis = TRUE, torque about axis = FALSE;
FORCE:F_F[V] ← GLLOP; ! Get force frame spec;
FORCE:CF[V] ← IF FORCE:F_F[V] = RNULL THEN CURRENT_CF
ELSE F_FRAME:CF[FORCE:F_F[V]];
RETURN(V)
END "force";
[STIFFTYPE] BEGIN "stiffness"
V ← NEW_RECORD(STIFF);
! STIFF:STIFFNESS[V] ← LGROVEL(LLLOP); ! Get the 6 stiffness values;
STIFF:K[V] ← GLLOP; ! Get the 3 force values;
STIFF:G[V] ← GLLOP; ! Get the 3 torque values;
STIFF:F_F[V] ← GLLOP; ! Get force frame spec;
IF STIFF:F_F[V] = RNULL THEN ! Fill in default force_frame;
BEGIN
STIFF:F_F[V] ← NEW_RECORD(F_FRAME);
F_FRAME:FRAME[STIFF:F_F[V]] ← STATION; ! Use standard orientation;
F_FRAME:C_SYS[STIFF:F_F[V]] ← FTABLE; ! Use table coordinates;
F_FRAME:CF[STIFF:F_F[V]] ← CURRENT_CF; ! Current arm;
END;
RETURN(V)
END "stiffness";
[GATHERTYPE] BEGIN "gather"
V ← NEW_RECORD(GATHER);
IX ← 0;
WHILE C ≠ RNULL DO ! See what forces we're to gather;
BEGIN
STRING S;
S ← IDENT:ID[CELL:CAR[C]];
IX ← IX LOR
(IF EQU(S,"TBL") THEN 1 LSH 12 ELSE
IF S = "F" THEN 1 LSH (S[2 TO 2] - "X") ELSE
IF S = "M" THEN 1 LSH (S[2 TO 2] - "X" + 3) ELSE
IF S = "T" THEN 1 LSH (S[2 TO 2] - "1" + 6) ELSE 0);
LLOP(C)
END;
GATHER:BITS[V] ← IX; ! Store away forces to gather;
RETURN(V)
END "gather";
[F_FRAMETYPE] BEGIN "force frame"
V ← NEW_RECORD(F_FRAME);
F_FRAME:FRAME[V] ← GLLOP;
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
F_FRAME:C_SYS[V] ← IF IX = "⊗" THEN FHAND ELSE FTABLE;
F_FRAME:CF[V] ← GLLOP; ! See if explicit control frame;
IF F_FRAME:CF[V] = RNULL THEN F_FRAME:CF[V] ← CURRENT_CF;
RETURN(V)
END "force frame";
[SETBASETYPE] BEGIN "setbase" ! This and WRIST below are temp hacks;
V ← NEW_RECORD(SETBASE);
IF C ≠ NULL_RECORD THEN
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
SETBASE:VAL[V] ← IF IX = "-" THEN FALSE ELSE TRUE;
RETURN(STMAKE(V))
END "setbase";
[WRISTTYPE] BEGIN "wrist"
V ← NEW_RECORD(WRIST);
WRIST:K[V] ← GLLOP;
WRIST:G[V] ← GLLOP;
RETURN(STMAKE(V))
END "wrist";
[S_FACTYPE] BEGIN "speed_factor"
V ← NEW_RECORD(S_FAC);
S_FAC:VAL[V] ← GLLOP;
RETURN(STMAKE(V))
END "speed_factor";
[NNULLTYPE] BEGIN "nnull"
V ← NEW_RECORD(NNULL);
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
NNULL:FLAG[V] ← IF IX = "+" THEN TRUE ELSE FALSE;
RETURN(V)
END "nnull";
[RTMOVETYPE] BEGIN "rtmove" ! Use runtime traj calc - hack for msm;
V ← NEW_RECORD(RTMOVE);
RETURN(V)
END "rtmove";
[SW_TIMETYPE] BEGIN "stop_wait_time"
V ← NEW_RECORD(SW_TIME);
SW_TIME:VAL[V] ← GLLOP;
RETURN(STMAKE(V))
END "stop_wait_time";
[CWTYPE] BEGIN
V ← NEW_RECORD(CW);
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
CW:FLAG[V] ← IF IX = "-" THEN TRUE ELSE FALSE;
RETURN(STMAKE(V))
END;
[TO$TYPE] BEGIN "to" ! Used for alternative MOVE syntax;
V ← NEW_RECORD(TO$);
TO$:VAL[V] ← GLLOP; ! Get destination for MOVE;
RETURN(V)
END "to";
ELSE RETURN(RNULL)
END
END;
ELSE END;
RETURN(SE)
END;
END $$PRGID;